Shareware Overload Trio 2

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir42 / c7105.zip / FORM.TPX < prev next >

Wrap

Text File | 1994-03-02 | 21KB | 469 lines

#!┌───────────────────────────┤Template Segment├───────────┬─────────────────┐ #!│ Form.TPX │Version: 3007.105│ #!├───────────────────────────────┤Contents├───────────────┴─────────────────┤ #!│Structure Type Description │ #!│──────────────────── ───────── ─────────────────────────────────────────│ #!│ PROCEDURE Update a browse or lookup with a form │ #!├───────────────────────────────┤Comments├─────────────────────────────────┤ #!│Version Comments │ #!│──────── ────────────────────────────────────────────────────────────────│ #!│3007.000 Release of CDD3 version 3007 templates │ #!│3007.100 Repaired Form Procedure │ #!│3007.101 Modified Form Procedure │ #!│3007.103 Modified Form Procedure │ #!│3007.105 Modified Form Procedure │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #PROCEDURE(Form,'Update a browse or lookup with a form'),SCREEN,PULLDOWN #! #!┌──────────────────────────┤Procedure Template├──────────┬─────────────────┐ #!│ Form │Version: 3007.103│ #!├──────────────────────────────┤Description├─────────────┴─────────────────┤ #!│The Form Template generates a file update procedure. A procedure │ #!│generated with this template assumes that: │ #!│ 1. Keycode will be Enter, Insert or Delete upon procedure initialization│ #!│ 2. If Keycode is Enter or Delete, the record buffer contains a valid │ #!│ record, and that record reflects the current active record of Primary│ #!│ 3. If Keycode is Insert, the record buffer contains a cleared record, │ #!│ with any necessary key fields primed. │ #!│Upon completion of Editing or deleting a record, the Form procedure will │ #!│process any files referenced to Primary in a 1:Many constrained │ #!│relationship. │ #!├───────────────────────────────┤Comments├─────────────────────────────────┤ #!│Version Comments │ #!│──────── ────────────────────────────────────────────────────────────────│ #!│3007.000 Release of CDD3 version 3007 templates │ #!│3007.100 Repaired CANCEL code (on single entry forms, called as deletes, │ #!│ the CANCEL field code should not perform a GET(file,0). This │ #!│ repair fixes a problem with cancelled deletes affecting totals │ #!│ on the calling browse procedure. │ #!│3007.101 Added "Disable RI Logout" Prompt. This prompt is added to allow│ #!│ the disabling of the LOGOUT function during RI Updates and │ #!│ Deletes. This is necessary if RI Code is generated to handle │ #!│ multiple relations between files. │ #!│3007.103 Added Enabling of LOC:Message on Delete Action (mainly for GUI) │ #!│3007.105 Completed support for PullDowns │ #!│ Moved call to ShowWarning in I/O code to WARNINGS.TPX │ #!│ Repaired Change Action code with regard to AutoNumber ADDs │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #PROTOTYPE('') #PROMPT('Insert message',@S30),%InsertMsg #PROMPT('Chan&ge message',@S30),%ChangeMsg #PROMPT('De&lete message',@S30),%DeleteMsg #PROMPT('Action after ADD',OPTION),%AddAction #PROMPT('Return to caller ',RADIO) #PROMPT('Retain Record ',RADIO) #PROMPT('Clear Record ',RADIO) #PROMPT('Copy field hot&key:',KEYCODE),%CopyKey #PROMPT('Next &Procedure ',PROCEDURE),%NextProcedure #PROMPT('Disable RI Logout',CHECK),%NoLogoutSupport #INSERT(%StandardHeader) #INSERT(%InitFormSymbols) #INSERT(%PrimaryDriverCheck) #IF(%Primary = %NULL) #SET(%ErrorMessage,(' WARNING during Code Generation in Procedure: '& %Procedure )) #ERROR(%ErrorMessage) #SET(%ErrorMessage,( ' No File Defined In File Schematic For FORM Template ')) #ERROR(%ErrorMessage) #ENDIF %Procedure PROCEDURE %LocalData NoMoreFields BYTE(0) !No more fields flag NonStopSelect BYTE(0) #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) SCREEN %ScreenAttributes,ALRT(%CopyKey) %ScreenPaintDeclarations %ScreenStringDeclarations %ScreenFieldDeclarations . #IF(%SharedFiles = %NULL) #IF(%PrimaryDriver <> 'Btrieve') SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV) #ENDIF #ENDIF #ELSE %ScreenStructure #IF(%SharedFiles = %NULL) #IF(%PrimaryDriver <> 'Btrieve') SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV) #ENDIF #ENDIF #ENDIF #ELSE %ScreenStructure #ENDIF #IF(%PullDown) %PullDownStructure SAV::PullDownOpened BYTE(0) #ENDIF #IF(%SharedFiles OR %PrimaryDriver = 'Btrieve') RecordQueue QUEUE,PRE(SAV) !Queue for concurrency checking SaveRecord LIKE(%FilePre:Record),PRE(SAV) #<!size of primary file record #FOR(%FileMemo) #FIX(%Field,%FileMemo) SAV:%FieldID STRING(SIZE(%FileMemo)) #ENDFOR END #<!End Queue structure #ENDIF #INSERT(%FileControl) #!Declare Flags for file access AbortTransaction BYTE #IF(%RelatedChildList) #SET(%ProcessingFile,%Primary) #INSERT(%RelationalAccessFlds) #<!Declare link fields RI:RestrictUpdate BYTE RI:RestrictDelete BYTE #IF(%PrimaryDriver = 'Paradox3') #FIX(%File,%Primary) UpdRelation STRING(SIZE(%FilePre:Record)) #<!Position of last related record #ELSE UpdRelation STRING(10) #<!Position of last related record #ENDIF #IF(%PrimaryDriver='Btrieve') SAV:Position STRING(255) #ENDIF #ENDIF #INSERT(%DeclareAutoInc) #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') LastPosition STRING(10) !Position of last ADD #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%FieldDups) #ENDIF #ENDIF #IF(%PrimeKeysExist) #INSERT(%SavePrimedFields) #ENDIF #EMBED('Data Section') CODE #EMBED('Setup Procedure') #INSERT(%FileControl) #!Open files #INSERT(%SavePrimaryLinks) NonStopSelect = FALSE CASE KEYCODE() !What Key was pressed? OF InsKey !Insert a new record Action = AddRecord !Set action code 1 (ADD) #INSERT(%InsertMessage) #<!Message for ADD RECORD #IF(%AutoInc) DO AutoNumber !Set autonumber key field(s) #ELSE #INSERT(%ClearValues) #ENDIF #EMBED('On Add After Record Buffer Is Cleared') #IF(%InitRoutine) #<!Field(s) initial value DO InitializeFields !Initial values from dictionary #ENDIF OF EnterKey !Process a CHANGE request OROF MouseLeft2 !on EnterKey or double mouse Action = ChangeRecord !Set action code 2 (CHANGE) #INSERT(%ChangeMessage) #<!Message for CHANGE RECORD #IF(%SharedFiles) #INSERT(%SetupConcurrency) #<!Setup multi-user Concurrency #ENDIF OF DelKey !Process a DELETE request Action = DeleteRecord !Set action code 3 (DELETE) #INSERT(%DeleteMessage) #<!Message for DELETE RECORD SavePointer = POSITION(%Primary) #<!Position in PRIMARY file END !End CASE Keycode #FOR(%Formula) #IF(UPPER(%FormulaClass) = 'SETUP') #INSERT(%GenerateFormula) #ENDIF #ENDFOR #IF(%SecondaryExist) #<!IF schema has a Secondary DO SecondaryLookups !Read any lookup fields #ENDIF #IF(%PullDownStructure) OPEN(%PullDown) SAV::PullDownOpened = True #EMBED('Setup Pulldown') #! Embedded Source Code #ENDIF OPEN(%Screen) !Open the FORM screen IF Action = DeleteRecord !IF request for DELETE DISABLE(1,FIELDS()) !Disable all screen fields ENABLE(?OK) !Enable the OK and the ENABLE(?Cancel) !Cancel buttons #FOR(%ScreenField) #IF(UPPER(%ScreenFieldUse)='LOC:MESSAGE') ENABLE(?LOC:Message) !and the message display #BREAK #ENDIF #ENDFOR END !End IF request for delete #EMBED('Setup Screen') #SET(%ProcessingFile,%Primary) DISPLAY !Display screen fields LOOP !Begin Main process loop #EMBED('Beginning of Accept Loop') #IF(%SecondaryExist) #<!IF File schema has Secondary #INSERT(%SecondaryChanged) #ENDIF #IF(%LoopFormulasExist = 'Y') #<!Are there Formula fields? #SET(%GenerateFormulasOn,'Y') DO FormulaFields !Calculate Formula fields #ENDIF CASE SELECTED() !Process selected Field #INSERT(%ScreenSetupRoutines) OF NoMoreFields !User pressed Enter or OK #EMBED('Before File I/O') CASE Action !Process requested Action OF AddRecord !Action = 1 (ADD) ADD(%Primary) #<!Add Record to Primary file OF ChangeRecord !Action = 2 (Change) #IF(%AutoInc) IF AutoIncAdd #<!Was this an Autonumber? #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') LastPosition = POSITION(%Primary) #<!Save last record position #ENDIF PUT(%Primary) #<!Write the Record ELSE #<!not AutoincAdd #ENDIF #IF(%SharedFiles) DO ConcurrentWrite !Concurrent update ROUTINE IF AbortTransaction !AbortWrite is on SELECT(?Cancel) CYCLE !Let user choose response END !End AbortWrite# #ENDIF #IF(%UpdateChildList) DO ConstrainedUpdate #<!Write the Record IF AbortTransaction SELECT(?Cancel) CYCLE END #ELSE PUT(%Primary) #ENDIF #IF(%AutoInc) END #<!IF AutoIncAdd #ENDIF OF DeleteRecord !Action = 3 (Delete) #IF(%SharedFiles) DO ConcurrentDelete IF AbortTransaction SELECT(?Cancel) CYCLE END #ENDIF #IF(%DeleteChildList) DO ConstrainedDelete #<!Write the Record IF AbortTransaction SELECT(?Cancel) CYCLE END #ELSE DELETE(%Primary) #ENDIF ELSE DO ProcedureReturn END !End CASE Action IF ERRORCODE() !Error check on File I/O #IF(%DupKeyCheck) #INSERT(%DupKeyCode) #ENDIF #INSERT(%UpdateErrorMsg) #IF(%SharedFiles) RELEASE(%Primary) #<!Release the held record FREE(RecordQueue) !FREE the memory Queue #ENDIF DISABLE(1,FIELDS()) !Disable all the fields ENABLE(?Cancel) !Enable Cancel button SELECT(?Cancel) !and place cursor on Cancel DISPLAY !Re-display the screen CYCLE !Re-start main LOOP ELSE !Else no errorcode() #IF(%SharedFiles) FREE(RecordQueue) !Free memory from Queue #ENDIF #IF(%NextProcedure) #EMBED('Setup Next Procedure') %NextProcedure #<!Call the Next Procedure #EMBED('Return from Next Procedure') #ENDIF #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') IF Action = AddRecord #<!If Action is AddRecord LastPosition = POSITION(%Primary) #<!Save position of last ADD END #<!End IF Action = AddRecord #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'CLEAR RECORD') IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd) #INSERT(%InsertMessage) #<!Message for ADD RECORD #FIX(%File,%Primary) #INSERT(%ClearValues) DISPLAY !Update screen display #IF(%AutoInc) DO NextAutoNumber !Increment autonumber key #IF(%InitRoutine) DO InitializeFields !Initial value from DataDictionary #ENDIF DISPLAY !Display screen field #ENDIF SELECT(1) !Place cursor on 1st field #EMBED('After ADD on Retain and Clear record') CYCLE !Re-start main LOOP END !End IF (Action = ....) #ELSIF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd) #IF(%CopyKey <> %NULL) DO SaveScrFlds #<!Save the Screen fields #INSERT(%InsertMessage) #<!Message for ADD RECORD DISPLAY !Update screen display #FIX(%File,%Primary) CLEAR(%FilePre:Record) #<!Clear the record buffer #ELSE #IF(%AutoInc) SAV:SaveRecord = %FilePre:Record #<!Save the record buffer #ENDIF #ENDIF DISPLAY #IF(%AutoInc) DO NextAutoNumber !Increment autonumber key %FilePre:Record = SAV:SaveRecord #<!Restore saved record #INSERT(%RestoreAuto) #<!Restore AutoNumber(s) DISPLAY !Display screen fields #ENDIF SELECT(1) !Place cursor on 1st field #EMBED('After ADD on Retain and Clear record') CYCLE !Re-start main LOOP END !End IF (Action = ....) #ENDIF #!End %AddAction code BREAK !Break from main Loop END !End IF Errorcode() END !End CASE Selected() ACCEPT !Enable screen entry IF NonStopSelect IF KEYCODE() NonStopSelect = FALSE END END #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%DupFldCall) #ENDIF #ENDIF CASE KEYCODE() OF EscKey !User pressed Escape key IF FIELD() <> ?Cancel AND FIELD() > 0 !If user pressed Escape SELECT(?Cancel) !Select Cancel button PRESS(EnterKey) !Process Cancel button code CYCLE !Cycle to Accept END !Field was not Cancel button #IF(%HotKeysExist) #FOR(%HotKey) OF %HotKey !User defined HotKey %HotKeyProc !HotKey Procedure #ENDFOR #ENDIF END !End CASE Keycode CASE FIELD() !Process fields #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Ok') OF ?Ok !On the OK button #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field Edit procedure #ENDIF SELECT(1) !Start with the first field SELECT !and cycle non-stop NonStopSelect = TRUE !Set Up for Non-Stop Select SETKEYCODE(0) !Clear the KeyCode CYCLE !restart main process loop #ELSIF(%ScreenFieldUse = '?Cancel') OF ?Cancel !On Cancel button #IF(%AutoInc = 'Y') IF AutoIncAdd !ADDed autoincrement record? RESET(%Primary,AutoAddPtr) #<!Re-position record pointer NEXT(%Primary) #<!Re-read the record we added IF DiskError('Could not READ Record') !Check for file I/O error DO ProcedureReturn END !End IF Diskerror DELETE(%Primary) #<!DELETE the record IF DiskError('Record could not be Deleted') DO ProcedureReturn END !End IF Diskerror END !End IF AutoIncAdd #ENDIF #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') IF LastPosition #<!IF a record was added RESET(%Primary,LastPosition) #<!Position to the record NEXT(%Primary) #<!and read it ELSE #<!Else no LastPosition GET(%Primary,0) #<!signal Browse to re-read END #<!END If LastPosition #ELSE IF Action <> DeleteRecord #<! IF not called to delete GET(%Primary,0) #<! signal Browse to re-read END #<! END (IF not called...) #ENDIF DO ProcedureReturn #ELSE #INSERT(%ScreenEditRoutines) #ENDIF #ENDFOR #FOR(%PulldownField) #! add all procedure or #IF(%PulldownFieldType = 'PROCEDURE') #! source code calls OF %PulldownField #<!For a Pulldown field %PulldownFieldProc #<! execute its procedure #ENDIF #ENDFOR END !End CASE FIELD END !END MAIN PROCESS LOOP #FOR(%Formula) #IF(UPPER(%FormulaClass) = 'RETURN') #INSERT(%GenerateFormula) #<!Return Class formula #ENDIF #ENDFOR DO ProcedureReturn !───────────────────────────────────────────────────────────────────────────── ProcedureReturn ROUTINE #IF(%SharedFiles) #IF(%AutoInc) IF Action = ChangeRecord AND AutoIncAdd RELEASE(%Primary) END #ENDIF #ENDIF #IF(%PullDownStructure) IF SAV::PullDownOpened CLOSE(%PullDown) END #ENDIF #IF(%SharedFiles) FREE(RecordQueue) #ENDIF #EMBED('Before Closing Screen') #EMBED('Before Closing Files') #INSERT(%FileControl) #!Open files DO EndOfProcedureEmbed RETURN !───────────────────────────────────────────────────────────────────────────── EndOfProcedureEmbed ROUTINE #EMBED('End of Procedure') #EMBED('Custom Routines') #INSERT(%AutoIncCode) #INSERT(%ConcurrentWrite) #INSERT(%ConcurrentDelete) #INSERT(%RIUpdates) #INSERT(%RIDeletes) #INSERT(%InitQue) #INSERT(%InitFields) #INSERT(%GenFormulas) #IF(%SecondaryExist) #INSERT(%SecondaryLookups) #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%SaveScrFlds) #INSERT(%DupField) #ENDIF #ENDIF #CHAIN('MultiPg.tpx')